home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlsubr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  5.7 KB  |  226 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlsubr.c
  5. * RCS:          $Header: xlsubr.c,v 1.4 91/03/24 22:25:33 mayer Exp $
  6. * Description:  xlisp builtin function support routines
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:12:25 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlsubr.c,v 1.4 91/03/24 22:25:33 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* external variables */
  48. extern LVAL k_test,k_tnot,s_eql;
  49.  
  50. /* xlsubr - define a builtin function */
  51. LVAL xlsubr(sname,type,fcn,offset)
  52.   char *sname; int type; LVAL (*fcn)(); int offset;
  53. {
  54.     LVAL sym;
  55.     sym = xlenter(sname);
  56.     setfunction(sym,cvsubr(fcn,type,offset));
  57.     return (sym);
  58. }
  59.  
  60. /* xlgetkeyarg - get a keyword argument */
  61. int xlgetkeyarg(key,pval)
  62.   LVAL key,*pval;
  63. {
  64.     LVAL *argv=xlargv;
  65.     int argc=xlargc;
  66.     for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
  67.     if (*argv == key) {
  68.         *pval = *++argv;
  69.         return (TRUE);
  70.     }
  71.     }
  72.     return (FALSE);
  73. }
  74.  
  75. /* xlgkfixnum - get a fixnum keyword argument */
  76. int xlgkfixnum(key,pval)
  77.   LVAL key,*pval;
  78. {
  79.     if (xlgetkeyarg(key,pval)) {
  80.     if (!fixp(*pval))
  81.         xlbadtype(*pval);
  82.     return (TRUE);
  83.     }
  84.     return (FALSE);
  85. }
  86.  
  87. /* xltest - get the :test or :test-not keyword argument */
  88. xltest(pfcn,ptresult)
  89.   LVAL *pfcn; int *ptresult;
  90. {
  91.     if (xlgetkeyarg(k_test,pfcn))    /* :test */
  92.     *ptresult = TRUE;
  93.     else if (xlgetkeyarg(k_tnot,pfcn))    /* :test-not */
  94.     *ptresult = FALSE;
  95.     else {
  96.     *pfcn = getfunction(s_eql);
  97.     *ptresult = TRUE;
  98.     }
  99. }
  100.  
  101. /* xlgetfile - get a file or stream */
  102. LVAL xlgetfile()
  103. {
  104.     LVAL arg;
  105.  
  106.     /* get a file or stream (cons) or nil */
  107.     if (arg = xlgetarg()) {
  108.     if (streamp(arg)) {
  109.         if (getfile(arg) == NULL)
  110.         xlfail("file not open");
  111.     }
  112.     else if (!ustreamp(arg))
  113.         xlerror("bad argument type",arg);
  114.     }
  115.     return (arg);
  116. }
  117.  
  118. /* xlgetfname - get a filename */
  119. LVAL xlgetfname()
  120. {
  121.     LVAL name;
  122.  
  123.     /* get the next argument */
  124.     name = xlgetarg();
  125.  
  126.     /* get the filename string */
  127.     if (symbolp(name))
  128.     name = getpname(name);
  129.     else if (!stringp(name))
  130.     xlerror("bad argument type",name);
  131.  
  132.     /* return the name */
  133.     return (name);
  134. }
  135.  
  136. /* needsextension - check if a filename needs an extension */
  137. int needsextension(name)
  138.   char *name;
  139. {
  140.     char *p;
  141.  
  142.     /* check for an extension */
  143.     for (p = &name[strlen(name)]; --p >= &name[0]; )
  144.     if (*p == '.')
  145.         return (FALSE);
  146.     else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
  147.         return (TRUE);
  148.  
  149.     /* no extension found */
  150.     return (TRUE);
  151. }
  152.  
  153. /* xlbadtype - report a "bad argument type" error */
  154. LVAL xlbadtype(arg)
  155.   LVAL arg;
  156. {
  157.     xlerror("bad argument type",arg);
  158. }
  159.  
  160. /* xltoofew - report a "too few arguments" error */
  161. LVAL xltoofew()
  162. {
  163.     xlfail("too few arguments");
  164. }
  165.  
  166. /* xltoomany - report a "too many arguments" error */
  167. xltoomany()
  168. {
  169.     xlfail("too many arguments");
  170. }
  171.  
  172. /* eq - internal eq function */
  173. int eq(arg1,arg2)
  174.   LVAL arg1,arg2;
  175. {
  176.     return (arg1 == arg2);
  177. }
  178.  
  179. /* eql - internal eql function */
  180. int eql(arg1,arg2)
  181.   LVAL arg1,arg2;
  182. {
  183.     /* compare the arguments */
  184.     if (arg1 == arg2)
  185.     return (TRUE);
  186.     else if (arg1) {
  187.     switch (ntype(arg1)) {
  188.     case FIXNUM:
  189.         return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  190.     case FLONUM:
  191.         return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  192.     default:
  193.         return (FALSE);
  194.     }
  195.     }
  196.     else
  197.     return (FALSE);
  198. }
  199.  
  200. /* equal - internal equal function */
  201. int equal(arg1,arg2)
  202.   LVAL arg1,arg2;
  203. {
  204.     /* compare the arguments */
  205.     if (arg1 == arg2)
  206.     return (TRUE);
  207.     else if (arg1) {
  208.     switch (ntype(arg1)) {
  209.     case FIXNUM:
  210.         return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  211.     case FLONUM:
  212.         return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  213.     case STRING:
  214.         return (stringp(arg2) ? strcmp(getstring(arg1),
  215.                        getstring(arg2)) == 0 : FALSE);
  216.     case CONS:
  217.         return (consp(arg2) ? equal(car(arg1),car(arg2))
  218.                    && equal(cdr(arg1),cdr(arg2)) : FALSE);
  219.     default:
  220.         return (FALSE);
  221.     }
  222.     }
  223.     else
  224.     return (FALSE);
  225. }
  226.